home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / 12a.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  34.3 KB  |  1,153 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. /* chapter 12 - part a*/
  11. #include "hdr.h"
  12. #include "vars.h"
  13. #include "libhdr.h"
  14. #include "attr.h"
  15. #include "unitsprots.h"
  16. #include "errmsgprots.h"
  17. #include "miscprots.h"
  18. #include "smiscprots.h"
  19. #include "setprots.h"
  20. #include "libprots.h"
  21. #include "dclmapprots.h"
  22. #include "nodesprots.h"
  23. #include "chapprots.h"
  24.  
  25. static Tuple collect_generic_formals(Node);
  26. static void add_implicit_neq(Tuple, Node, Symbol);
  27. static void bind_names(Node);
  28.  
  29. void generic_subprog_spec(Node node)     /*;generic_subprog_spec*/
  30. {
  31.     int        nat, kind, i;
  32.     Node    id_node, generic_part_node, ret_node, formals_list;
  33.     int        f_mode, body_number;
  34.     char    *obj_id;
  35.     Symbol    gen_name, form_name, scope;
  36.     Tuple    gen_list, form_list;
  37.     Tuple    tup;
  38.     Node    formal_node, id_list, m_node, type_node, exp_node, init_node;
  39.     Symbol    type_mark;
  40.     Tuple    f_ids;
  41.     char    *id;
  42.     Fortup    ft1, ft2;
  43.  
  44.     /*
  45.      * Build specifications     of a  generic subprogram. We create  a scope for
  46.      * it, and  define within the  names of generics and  formal  parameters.
  47.      * The signature of the generic subprogram includes the generic parameter
  48.      * list and the formals. These two are unpacked during instantiation.
  49.      */
  50.     if (cdebug2 > 3)
  51.         TO_ERRFILE("AT PROC :  generic_subprog_spec ");
  52.  
  53.     id_node = N_AST1(node);
  54.     generic_part_node = N_AST2(node);
  55.     formals_list = N_AST3(node);
  56.     ret_node = N_AST4(node);
  57.     kind = N_KIND(node);
  58.  
  59.     obj_id = N_VAL(id_node);
  60.     new_compunit("ss", id_node);
  61.  
  62.     if (IS_COMP_UNIT) {
  63.         /* allocate unit number for body, and mark it obsolete */
  64.         body_number = unit_number(strjoin("su", obj_id));
  65.         pUnits[body_number]->libInfo.obsolete = string_ds; /*"$D$"*/
  66.     }
  67.  
  68.     gen_name = find_new(obj_id);
  69.     N_UNQ(id_node) = gen_name;
  70.     DECLARED(gen_name) = dcl_new(0);
  71.     NATURE(gen_name) = na_generic_part;
  72.     formal_decl_tree(gen_name) = (Symbol) formals_list;
  73.     newscope(gen_name);
  74.  
  75.     adasem(generic_part_node);
  76.     gen_list = collect_generic_formals(generic_part_node);
  77.     /*
  78.      * Now declared(gen_name) contains  the generic parameters: types,
  79.      * objects and    subprograms.
  80.      *
  81.      * For the formal parameters, we simply must recognize their names
  82.      * and    types. Type  checking on  initialization  is  repeated    on
  83.      * instantiation.
  84.      */
  85.     NATURE(gen_name) = na_void;        /* To catch premature usage. */
  86.     form_list = tup_new(0);
  87.  
  88.     FORTUP(formal_node =(Node), N_LIST(formals_list), ft1);
  89.         id_list = N_AST1(formal_node);
  90.         m_node = N_AST2(formal_node);
  91.         type_node = N_AST3(formal_node);
  92.         exp_node = N_AST4(formal_node);
  93.         type_mark = find_type(copy_tree(type_node));
  94.  
  95.         if (exp_node != OPT_NODE) {
  96.             adasem(exp_node);
  97.             init_node = copy_tree(exp_node);
  98.             normalize(type_mark, init_node);
  99.         }
  100.         else init_node = OPT_NODE;
  101.         current_node = formal_node;
  102.         f_ids = tup_new(tup_size(N_LIST(id_list)));
  103.         FORTUPI(id_node=(Node), N_LIST(id_list), i, ft2);
  104.             f_ids[i] = N_VAL(id_node);
  105.         ENDFORTUP(ft2);
  106.         f_mode = (int) N_VAL(m_node);
  107.         if (f_mode == 0 ) f_mode = na_in;
  108.  
  109.         FORTUP(id=, f_ids, ft2);
  110.             form_name = find_new(id);
  111.             NATURE(form_name)  = f_mode;
  112.             TYPE_OF(form_name) = type_mark;
  113.             default_expr(form_name) = (Tuple) copy_tree(init_node);
  114.             form_list = tup_with(form_list, (char *) form_name);
  115.         ENDFORTUP(ft2);
  116.  
  117.         if (f_mode != na_in && kind == as_generic_function) {
  118. #ifdef ERRNUM
  119.             l1_errmsgn(nature_str(f_mode),31, 32, formal_node);
  120. #else
  121.             errmsg_l(nature_str(f_mode),
  122.               " parameter not allowed for functions", "6.5", formal_node);
  123. #endif
  124.         }
  125.         /*  enforce restrictions on usage of out formal parameters given in
  126.           *  LRM 7.4.4
  127.          */
  128.         scope = SCOPE_OF(type_mark);
  129.         nat = NATURE(scope);
  130.         if (f_mode != na_out || is_access(type_mark))
  131.             continue;
  132.         else if (TYPE_OF(type_mark) == symbol_limited_private
  133.             && (nat == na_package_spec || nat == na_generic_package_spec 
  134.             || nat == na_generic_part )
  135.             && !in_private_part(scope)
  136.             && tup_mem((char *)scope, open_scopes) ) {
  137.             /* We    are in the visible  part of  the package that declares
  138.              * the type. Its  full  decl. will  have to be  given with an
  139.              * assignable type.
  140.               */
  141.             misc_type_attributes(type_mark) =  
  142.             (misc_type_attributes(type_mark)) | TA_OUT;
  143.         }
  144.         else if (is_limited_type(type_mark)) {
  145. #ifdef ERRNUM
  146.             id_errmsgn(33, type_mark, 34, formal_node);
  147. #else
  148.             errmsg_id("Invalid use of limited type % for out parameter ",
  149.               type_mark, "7.4.4", formal_node);
  150. #endif
  151.         }
  152.     ENDFORTUP(ft1);
  153.     /*
  154.      * Save signature of generic object, in the format which the
  155.      * instantiation procedure requires.
  156.      */
  157.     NATURE(gen_name) =
  158.         (kind == as_generic_procedure) ? na_generic_procedure_spec
  159.         : na_generic_function_spec;
  160.     tup = tup_new(4);
  161.     tup[1] = (char *) gen_list;
  162.     tup[2] = (char *) form_list;
  163.     tup[3] = (char *) OPT_NODE;
  164.     tup[4] = (char *) tup_new(0);
  165.     SIGNATURE(gen_name) = tup;
  166.     if (kind == as_generic_function) {
  167.         find_old(ret_node);
  168.         TYPE_OF(gen_name) = N_UNQ(ret_node);
  169.     }
  170.     else {
  171.         TYPE_OF(gen_name) = symbol_none;
  172.     }
  173.     popscope();
  174.  
  175.     save_subprog_info(gen_name);
  176. }
  177.  
  178. void generic_subprog_body(Symbol prog_name, Node node) /*;generic_subprog_body*/
  179. {
  180.     /*
  181.      * Within  its body,  the generic  subprogram  name behaves  as a regular
  182.      * (i.e. non-generic) subprogram. In  particular, it  can be  called (and
  183.      * it cannot be instantiated). Its nature must be set accordingly,  prior
  184.      * to compilation of the body.
  185.      */
  186.     int        new_nat, nat, i;
  187.     Tuple    sig, must_constrain;
  188.     Node    specs_node, decl_node, formals_node;
  189.     char    *spec_name;
  190.     char     *junk;
  191.     Tuple    specs, tup, gen_list, form_list, decscopes, decmaps, body_specs;
  192.     Symbol    generic_sym, g_name;
  193.     Unitdecl    ud;
  194.     Fortup    ft;
  195.  
  196.     /* if module is a generic subprogram body verify that the generic spec 
  197.      * appeared in the same file.
  198.      */
  199.     if (IS_COMP_UNIT) {
  200.         spec_name = strjoin("ss", unit_name_name(unit_name));
  201.         if (!streq(lib_unit_get(spec_name), AISFILENAME))
  202. #ifdef ERRNUM
  203.             errmsgn(35,10, node);
  204. #else
  205.         errmsg("Separately compiled generics not supported", "none", node);
  206. #endif
  207.     }
  208.  
  209.     if (NATURE(prog_name) == na_generic_procedure_spec) {
  210.         new_nat = na_procedure;
  211.         nat = na_generic_procedure; /* Save till end of body. */
  212.     }
  213.     else {
  214.         new_nat = na_function;
  215.         nat = na_generic_function;
  216.     }
  217.  
  218.     /*
  219.      * save and stack the generic symbol for this subprogram to allow the
  220.      * detection of recursive instantiations within the generic body
  221.      */
  222.     generic_sym = sym_new_noseq(na_void);
  223.     sym_copy(generic_sym, prog_name);
  224.     NATURE(generic_sym) = nat;
  225.     current_instances = tup_with(current_instances, (char *)  generic_sym);
  226.  
  227.     NATURE(prog_name) = new_nat;
  228.     /*
  229.      * The signature of a  generic object includes    the generic  part. During
  230.      * compilation of the body, set the signature to contain only the formals
  231.      */
  232.     sig = SIGNATURE(prog_name);
  233.     gen_list = (Tuple) sig[1];
  234.     form_list = (Tuple) sig[2];
  235.     SIGNATURE(prog_name) = (Tuple) form_list;
  236.     OVERLOADS(prog_name) = set_new1((char *) prog_name);
  237.  
  238.     specs_node   = N_AST1(node);
  239.     formals_node = N_AST2(specs_node);
  240.     decl_node    = N_AST2(node);
  241.     newscope(prog_name);
  242.     reprocess_formals(prog_name, formals_node);
  243.     process_subprog_body(node, prog_name);
  244.     force_all_types();
  245.     popscope();
  246.     /*
  247.      * If a generic subprogram parameter is an equality operator, we must
  248.      * construct the body for the corresponding implicitly defined inequality
  249.      */
  250.     add_implicit_neq(gen_list, decl_node, prog_name);
  251.  
  252.     /* Outside of its body, the object is generic again.*/
  253.     NATURE(prog_name) = nat;
  254.     junk = tup_frome(current_instances);
  255.  
  256.     /* collect all generic types whose '$constrain' attribute is set into the
  257.      * tuple must_constrain and save it in the signature of the body
  258.      */
  259.  
  260.     must_constrain = tup_new(0);
  261.     FORTUP(tup=(Tuple), gen_list, ft)
  262.         g_name = (Symbol)tup[1];
  263.         if ((int)misc_type_attributes(g_name) & TA_CONSTRAIN)
  264.             must_constrain = tup_with(must_constrain, (char *)g_name);
  265.     ENDFORTUP(ft)
  266.  
  267.     sig= tup_new(4);
  268.     sig[1] = (char *) gen_list;
  269.     sig[2] = (char *) form_list;
  270.     sig[3] = (char *) node;
  271.     sig[4] = (char *) must_constrain;
  272.     SIGNATURE(prog_name) = sig; /* for instantiation */
  273.     OVERLOADS(prog_name) = (Set) 0;    /* Not a callable object. */
  274.  
  275.     /*
  276.      * If the  corresponding spec was defined in another compilation unit, it
  277.      * must     be updated  accordingly. If the generic is not itself a compila-
  278.      * tion unit, we  find the unit in which it appears, and update the info.
  279.      * Currently this is done only if both units are in the same compilation.
  280.      */
  281.  
  282.     if (IS_COMP_UNIT) {
  283.         pUnits[unit_number(unit_name)]->libInfo.obsolete = string_ok;
  284.         /*save it as any subprogram body. */
  285.         save_subprog_info(prog_name);
  286.     }
  287.     else if (streq(unit_name_type(unit_name), "bo") &&
  288.       streq(unit_name_name(unit_name), unit_name_names(unit_name)) ) {
  289.         spec_name = strjoin("sp", unit_name_name(unit_name));
  290.         ud = unit_decl_get(spec_name);
  291.         if (streq(lib_unit_get(spec_name), FILENAME) && (ud!=(Unitdecl)0)) {
  292.             /* i.e. current compilation, and separate unit, already seen.
  293.               * update symbol table information for all entities in body.
  294.               * Probably incomplete on unit_nodes, declared, etc.
  295.              */
  296.             /* [n, specs, decmap, o, v, c, nodes] := UNIT_DECL(spec_name); */
  297.             specs = ud->ud_symbols;
  298.             body_specs = unit_symbtab(prog_name, 'u');
  299.  
  300.             /* (for [nam, info] in body_specs)
  301.              *   specs(nam) := info;
  302.              * end for;
  303.              */
  304.              for (i = 1; i <= tup_size(body_specs); i++)
  305.                 specs = sym_save(specs, (Symbol)body_specs[i], 'u');
  306.  
  307.              /* decmap(prog_name) := declared(prog_name); */
  308.             decscopes = ud->ud_decscopes;
  309.             decmaps   = ud->ud_decmaps;
  310.             for (i = 1; i<= tup_size(decscopes); i++)
  311.                 if (prog_name == (Symbol)(decscopes[i]))
  312.                     break;
  313.             decmaps[i] = (char *)dcl_copy(DECLARED(prog_name));
  314.             /* is copy necessary ? */
  315.  
  316.             /* UNIT_DECL(spec_name):= [n, specs, decmap, o, v, c, 
  317.                 *                       nodes + UNIT_NODES];
  318.                */
  319.             ud->ud_symbols = specs;
  320.             for (i = 1; i <= tup_size(unit_nodes); i++)
  321.                 ud->ud_nodes = tup_with(ud->ud_nodes, unit_nodes[i]);
  322.         }
  323.     }
  324.     else {
  325.         /* If it is a subunit of a subprogram unit, it is only visible within
  326.          * this unit, and no update is needed.
  327.          */
  328. #ifdef TBSL
  329.         unit_kind : = om;
  330. #endif
  331.     }
  332.  
  333.     N_KIND(node) = (nat == na_generic_procedure) ? as_generic_procedure
  334.         : as_generic_function;
  335. }
  336.  
  337. static void add_implicit_neq(Tuple gen_list, Node decl_node, Symbol prog_name)
  338. /*;add_implicit_neq*/
  339. {
  340.     /*
  341.      * if a generic subprogram parameter is an equality operator, an implicit
  342.      * inequality is thus defined, and a symbol table entry for it has been
  343.      * constructed at the same time as that for the equality. We place a 
  344.      * declaration for its body in the declarative    part of the generic unit.
  345.      * It  will thus  be instantiated in the same way as other local entity.
  346.      */
  347.     Fortup    ft1;
  348.     Forset    fs1;
  349.     Tuple    tup;
  350.     Symbol    g_name, neq;
  351.     int        exists;
  352.     Node    neq_node;
  353.     Set        oset;
  354.  
  355.     FORTUP(tup=(Tuple), gen_list, ft1);
  356.         g_name = (Symbol) tup[1];
  357.  
  358.         if (NATURE(g_name) != na_function) continue;
  359.         if (streq(original_name(g_name), "=") == FALSE) continue;
  360.         exists = FALSE;
  361.         oset = (Set)OVERLOADS(dcl_get(DECLARED(prog_name), "/="));
  362.         FORSET(neq=(Symbol), oset, fs1);
  363.             if (same_signature(g_name, neq)) {
  364.                 exists = TRUE;
  365.                 break;
  366.             }
  367.         ENDFORSET(fs1);
  368.         if (!exists) continue;
  369.         neq_node = new_not_equals(neq, g_name);
  370. #ifdef TBSL
  371.         N_LIST(decl_node) :
  372.         = [neq_node] + N_LIST(decl_node);
  373. #endif
  374.         N_LIST(decl_node) = tup_with(N_LIST(decl_node), (char *)neq_node);
  375.     ENDFORTUP(ft1);
  376. }
  377.  
  378. void generic_pack_spec(Node node)     /*;generic_pack_spec*/
  379. {
  380.     Node    id_node, generic_part_node, decl_node, priv_node;
  381.     Tuple    tup, gen_list;
  382.  
  383.     if (cdebug2 > 3)
  384.         TO_ERRFILE("AT PROC :  generic_pack_spec");
  385.  
  386.     id_node = N_AST1(node);
  387.     generic_part_node = N_AST2(node);
  388.     decl_node = N_AST3(node);
  389.     priv_node = N_AST4(node);
  390.  
  391.     new_package(id_node, na_generic_part);
  392.  
  393.     /*
  394.      * Process generic parameters. Their definition will appear in
  395.      * the scope of the generic package. The list of them is also
  396.      * preserved in the signature of the package, for instantiation.
  397.      * The signature of the generic package as the format:
  398.      *
  399.      *  [[generic_type_list, visible_decls, private_part, body, must_constrain]
  400.      *
  401.      * The body will be seen later, its place kept by a null node.
  402.      * Must_constrain is the list of generic types that must be constrained upon
  403.      * instantiation. It is created by module_body after processing the generic
  404.      * package body.
  405.      */
  406.     adasem(generic_part_node);
  407.     tup = tup_new(5);
  408.     gen_list = collect_generic_formals(generic_part_node);
  409.     tup[1] = (char *) gen_list;
  410.     tup[2] = (char *) decl_node;
  411.     tup[3] = (char *) priv_node;
  412.     tup[4] = (char *) OPT_NODE;
  413.     tup[5] = (char *) tup_new(0);
  414.  
  415.     SIGNATURE(scope_name) = tup;
  416.     NATURE(scope_name)    = na_generic_package_spec;
  417.  
  418.     /* The rest of the package is processed as in a non-generic case.*/
  419.     package_declarations(decl_node, priv_node);
  420.     add_implicit_neq(gen_list, decl_node, scope_name);
  421.     end_specs(scope_name);
  422. }
  423.  
  424. void generic_obj_decl(Node node) /*;generic_obj_decl*/
  425. {
  426.     Node    id_list_node, in_out_node, type_node, init_node, id_node;
  427.     Tuple    id_nodes;
  428.     int        kind;
  429.     Symbol    type_mark, name;
  430.     Tuple    nam_list;
  431.     Fortup    ft1;
  432.     int        i;
  433.  
  434.     if (cdebug2 > 3)
  435.         TO_ERRFILE("AT PROC :  generic_obj_decl");
  436.  
  437.     id_list_node = N_AST1(node);
  438.     in_out_node = N_AST2(node);
  439.     type_node = N_AST3(node);
  440.     init_node = N_AST4(node);
  441.  
  442.     id_nodes = N_LIST(id_list_node);
  443.     nam_list = tup_new(tup_size(id_nodes));
  444.     FORTUPI(id_node=(Node), id_nodes, i, ft1);
  445.         nam_list[i] = (char *) find_new(N_VAL(id_node));
  446.     ENDFORTUP(ft1);
  447.     for (i = 1; i <= tup_size(id_nodes); i++)
  448.         N_UNQ((Node)id_nodes[i]) = (Symbol) nam_list[i];
  449.  
  450.     kind = (int) N_VAL(in_out_node);
  451.     if (kind == 0 ) kind = na_in;
  452.     find_type(type_node);
  453.     type_mark = N_UNQ(type_node);
  454.     if (is_incomplete_type(type_mark))
  455. #ifdef ERRNUM
  456.         id_errmsgn(36, type_mark, 37, type_node);
  457. #else
  458.         errmsg_id("Premature use of incomplete or private type %",
  459.           type_mark, "7.4.1", type_node);
  460. #endif
  461.     adasem(init_node);
  462.  
  463.     if (kind == na_in) {
  464.         if (is_limited_type(type_mark)) {
  465. #ifdef ERRNUM
  466.             l_errmsgn(38, 39, 40, type_node);
  467. #else
  468.             errmsg_l("Type of a generic formal object of mode IN must not",
  469.               " be a limited type", "12.1.1", type_node);
  470. #endif
  471.         }
  472.  
  473.         if (init_node != OPT_NODE) {
  474.             /* Type check  default value. */
  475.             bind_names(init_node);
  476.             check_type(type_mark, init_node);
  477.             if (is_deferred_constant(init_node) ) {
  478. #ifdef ERRNUM
  479.                 l_errmsgn(41, 42, 43, init_node);
  480. #else
  481.                 errmsg_l("Deferred constant cannot be default expression",
  482.                   " for a generic parameter", "7.4.3", init_node);
  483. #endif
  484.             }
  485.         }
  486.     }
  487.     else if (kind == na_inout) {
  488.         /* No constraints apply to generic inout formals.*/
  489.         type_mark = base_type(type_mark);
  490.  
  491.         if (init_node != OPT_NODE) {
  492. #ifdef ERRNUM
  493.             errmsgn(44,40, init_node);
  494. #else
  495.             errmsg("Initialization not allowed for IN OUT generic parameters",
  496.               "12.1.1", init_node);
  497. #endif
  498.         }
  499.     }
  500.     else if (kind == na_out) {
  501. #ifdef ERRNUM
  502.         errmsgn(45, 40, in_out_node);
  503. #else
  504.         errmsg("OUT generic formals objects not allowed",
  505.           "12.1.1", in_out_node);
  506. #endif
  507.     }
  508.  
  509.     FORTUP(name=(Symbol), nam_list, ft1);
  510.         if (kind == na_in) NATURE(name) =  na_in;
  511.         else NATURE(name)= na_inout;
  512.         TYPE_OF(name)   = type_mark;
  513.         SIGNATURE(name) = (Tuple) init_node;
  514.     ENDFORTUP(ft1);
  515. }
  516.  
  517. void generic_type_decl(Node node) /*;generic_type_decl*/
  518. {
  519.     Node    id_node, def_node, range_node, opt_disc;
  520.     char    *id, *root_id;
  521.     Symbol    root;
  522.     /*char    *attr;*/
  523.     Symbol    type_name, anon_type, generic_base, t;
  524.     Node    lo, hi, attr_node, precision, type_node;
  525.     Tuple    ncon, bounds;
  526.     int        kind;
  527.  
  528.     if (cdebug2 > 3)
  529.         TO_ERRFILE("AT PROC :  generic_type_decl");
  530.  
  531.     id_node = N_AST1(node);
  532.     opt_disc = N_AST2(node);
  533.     def_node = N_AST3(node);
  534.     id = N_VAL(id_node);
  535.     /*
  536.      * In the case of generic array types, anonymous parent array may be
  537.      * introduced. They are not generic in themselves, and play no role in
  538.      * the instantiated code; they are collected here and  discarded.
  539.      */
  540.     newtypes = tup_with(newtypes , (char *) tup_new(0));
  541.     if (N_KIND(def_node) == as_generic) {    /*scalar type*/
  542.         type_name = find_new(id);
  543.         N_UNQ(id_node) = type_name;
  544.         root_id = N_VAL(def_node);
  545.         if (streq(root_id, "INTEGER")) root = symbol_integer;
  546.         else if (streq(root_id, "discrete_type")) root = symbol_discrete_type;
  547.         else if (streq(root_id, "FLOAT")) root = symbol_float;
  548.         else if (streq(root_id, "$FIXED")) root = symbol_dfixed;
  549.         else chaos("generic_type_decl(12) bad generic type");
  550.  
  551.         /* A generic signature must be constructed for these types, in
  552.          * order to verify bounds  in instantiations,  subtypes,  etc.
  553.          * These bounds must expressed by means of attributes.
  554.          */
  555.         if (root == symbol_integer || root == symbol_discrete_type) {
  556.             type_node = new_name_node(type_name);
  557.             lo = new_attribute_node(ATTR_T_FIRST,type_node,OPT_NODE, type_name);
  558.             type_node = new_name_node(type_name);
  559.             hi = new_attribute_node(ATTR_T_LAST, type_node,OPT_NODE, type_name);
  560.             /*bounds := ['range', lo, hi];*/
  561.             bounds = constraint_new(CONSTRAINT_RANGE);
  562.             numeric_constraint_low(bounds) = (char *)lo;
  563.             numeric_constraint_high(bounds) = (char *)hi;
  564.             range_node = node_new(as_range);
  565.             N_AST1(range_node) = lo;
  566.             N_AST2(range_node) = hi;
  567.             N_AST1(def_node) = range_node;
  568.         }
  569.         else {
  570.             ncon = (Tuple) SIGNATURE(root);
  571.             kind = (int)numeric_constraint_kind(ncon);
  572.             lo = (Node) numeric_constraint_low(ncon);
  573.             hi = (Node) numeric_constraint_high(ncon);
  574.             /*[kind, lo, hi, precision] := signature(root);*/
  575.             attr_node = node_new(as_number);
  576.             /* proper attr code filled in below */
  577.             if (kind == CONSTRAINT_DIGITS) {
  578.                 N_VAL(attr_node) = (char *) ATTR_DIGITS;
  579.             }
  580.             else {
  581.                 N_VAL(attr_node) = (char *) ATTR_DELTA;
  582.                 /* N_VAL(attr_node) = if kind = 'digits' then 'DIGITS' 
  583.                   *    else 'DELTA' end;
  584.                   */
  585.             }
  586.             precision = node_new(as_attribute);
  587.             type_node = new_name_node(type_name);
  588.             N_AST1(precision) = attr_node;
  589.             N_AST2(precision) = type_node;
  590.             N_AST3(precision) = OPT_NODE;
  591. #ifdef TBSL
  592.             -- check this out, SETL seems wrong
  593.                 N_AST(def_node)  :
  594.             = precision;
  595. #endif
  596.             /*bounds = [kind, lo, hi, precision];*/
  597.             bounds = constraint_new(kind);
  598.             numeric_constraint_low(bounds) = (char *)lo;
  599.             numeric_constraint_high(bounds) = (char *)hi;
  600.             numeric_constraint_digits(bounds) = (char *)precision;
  601.         }
  602.         /* The base type of a generic type is the base of its actual. In
  603.          * order to be able to refer to the base type of a generic within
  604.          * the object, we introduce an anonymous type that will be instan
  605.          * tiated with the base type of the actual.
  606.          */
  607.         generic_base = anonymous_type();
  608.         NATURE(generic_base) = na_type;
  609.         TYPE_OF(generic_base) = root;
  610.         SIGNATURE(generic_base) = (Tuple) bounds;
  611.         root_type(generic_base) = root_type(root);
  612.         misc_type_attributes(generic_base) = TA_GENERIC;
  613.  
  614.         /*SYMBTAB(type_name) := [na_subtype, generic_base, bounds];*/
  615.         NATURE(type_name) = na_subtype;
  616.         TYPE_OF(type_name) = generic_base;
  617.         SIGNATURE(type_name) = bounds;
  618.         root_type(type_name) = root_type(root);
  619.     }
  620.     else {    /* array type or access type.*/
  621.         type_decl(node);
  622.         type_name = N_UNQ(id_node);
  623.         if (is_access(type_name))
  624.             t = (Symbol) designated_type(type_name);
  625.         else t = (Symbol) component_type(type_name);
  626.         /* note that a generic type defintion is not a type declaration and
  627.          * therefore, the component or designated type of a generic type
  628.          * cannot be an incomplete private type.
  629.          */
  630.         if (private_ancestor(t) != (Symbol)0 )
  631. #ifdef ERRNUM
  632.             id_errmsgn(46, t, 37, node);
  633. #else
  634.         errmsg_id("Premature usage of type % before its full declaration",
  635.           t, "7.4.1", node);
  636. #endif
  637.     }
  638.  
  639.     misc_type_attributes(type_name) =
  640.       misc_type_attributes(type_name) | TA_GENERIC;
  641.  
  642.     anon_type = (Symbol)tup_frome( newtypes);
  643. }
  644.  
  645. void generic_priv_decl(Node node)     /*;generic_priv_decl*/
  646. {
  647.     Node    id_node;
  648.     Symbol    type_name, discr;
  649.     Fortup    ft;
  650.  
  651.     if (cdebug2 > 3)
  652.         TO_ERRFILE("AT PROC :  generic_priv_decl");
  653.  
  654.     private_decl(node);
  655.  
  656.     id_node = N_AST1(node);
  657.     type_name = N_UNQ(id_node);
  658.     if (type_name == symbol_any)   /* previous error */
  659.         return;
  660.     misc_type_attributes(type_name) = TA_GENERIC;
  661.  
  662.     FORTUP(discr=(Symbol), discriminant_list(type_name), ft)
  663.         if (discr == symbol_constrained) continue;
  664.         if ((Node)default_expr(discr) != OPT_NODE) {
  665. #ifdef ERRNUM
  666.             errmsgn(47, 48, (Node)default_expr(discr));
  667. #else
  668.             errmsg(
  669.               "generic private type cannot have defaults for discriminants",
  670.               "12.1.2", (Node)default_expr(discr) );
  671. #endif
  672.             return;
  673.         }
  674.     ENDFORTUP(ft)
  675. }
  676.  
  677. void check_generic_usage(Symbol type_mark)    /*;check_generic_usage*/
  678. {
  679.     /*
  680.      * if a private generic type, or a subtype or derived type of it, is used
  681.      * in an object declaration, component declaration, or allocator, indicate
  682.      * that it must be instantiated with a constrained type.
  683.      */
  684.     Symbol    t;
  685.  
  686.     t = root_type(type_mark);
  687.  
  688.     if (in_priv_types(TYPE_OF(t)) && is_generic_type(t)
  689.       && (can_constrain(type_mark) || ! has_discriminants(type_mark)) )
  690.         misc_type_attributes(t) = misc_type_attributes(t) | TA_CONSTRAIN;
  691. }
  692.  
  693. void generic_subp_decl(Node node)     /*;generic_subp_decl*/
  694. {
  695.     Node    spec_node, opt_is_node, id_node, formal_list, ret_node;
  696.     char    *id;
  697.     Tuple    formals;
  698.     Symbol    ret, name, anon_subp;
  699.     int     kind;
  700.  
  701.     if (cdebug2 > 3)
  702.         TO_ERRFILE("AT PROC :  generic_subp_decl");
  703.  
  704.     spec_node = N_AST1(node) ;
  705.     opt_is_node = N_AST2(node) ;
  706.     adasem(spec_node);
  707.     id_node = N_AST1(spec_node);
  708.     formal_list = N_AST2(spec_node);
  709.     ret_node = N_AST3(spec_node);
  710.     id = N_VAL(id_node);
  711.     formals = get_formals(formal_list, id);
  712.     if (N_KIND(spec_node) == as_procedure ) {
  713.         kind = na_procedure;
  714.         ret = symbol_none;
  715.     }
  716.     else {
  717.         kind = na_function;
  718.         ret = N_UNQ(ret_node);
  719.     }
  720.     if (in_op_designators(id ))        /* check format, if operator spec */
  721.         check_new_op(id_node, formals, ret);
  722.     name = chain_overloads(id, kind, ret, formals, (Symbol)0, OPT_NODE);
  723.     N_UNQ(id_node) = name;
  724.  
  725.     /* a generic subprogram parameter is treated as a renaming of some
  726.      * unspecified subprogram whose actual name will be supplied at
  727.      * the point of instantiation
  728.      */
  729.     anon_subp = sym_new(kind);
  730.     TYPE_OF(anon_subp) = TYPE_OF(name);
  731.     SIGNATURE(anon_subp) = SIGNATURE(name);
  732.     SCOPE_OF(anon_subp) = scope_name;
  733.     dcl_put(DECLARED(scope_name), newat_str(), anon_subp);
  734.     ALIAS(name) = anon_subp;
  735.  
  736.     if (N_KIND(opt_is_node) == as_string) /* Default val is an operator name.*/
  737.         desig_to_op(opt_is_node);
  738.     else
  739.         adasem(opt_is_node) ;
  740.  
  741.     if (opt_is_node != OPT_NODE) {
  742.         if (N_KIND(opt_is_node) == as_simple_name
  743.             /* had 'box' in next line TBSL check type */
  744.         && streq(N_VAL(opt_is_node) , "box")) {
  745.             ;
  746.         }
  747.         else {
  748.             find_old(opt_is_node);
  749.             /* verify that the default has a matching signature */
  750.             current_node = opt_is_node;
  751.             if (tup_size(find_renamed_entity(kind,
  752.               formals, ret, opt_is_node)) == 0)
  753.                 N_AST2(node) = OPT_NODE; /* renaming error */
  754.             if (name == N_UNQ(opt_is_node))
  755. #ifdef ERRNUM
  756.                 str_errmsgn(49, id, 50, opt_is_node);
  757. #else
  758.             errmsg_str("invalid reference to %", id, "8.3(16)", opt_is_node);
  759. #endif
  760.         }
  761.     }
  762. }
  763.  
  764. static void bind_names(Node node)        /*;bind_names*/
  765. {
  766.     Node    name, sel, arg_list, arg1, arg2, arg;
  767.     Fortup    ft1;
  768.     int    nk;
  769.  
  770.     if (cdebug2 > 3)
  771.         TO_ERRFILE("AT PROC :  bind_names");
  772.     /*
  773.      * Perform name resolution for default initializations for generic IN
  774.      * parameters and for discriminant specifications.
  775.      */
  776.     switch (nk = N_KIND(node)) {
  777.       case    as_name:
  778.                 find_old(node);
  779.                 bind_names(node);
  780.                 break;
  781.       case    as_selector:
  782.                 name = N_AST1(node);
  783.                 sel = N_AST2(node);
  784.                 bind_names(name);
  785.                 break;
  786.       case    as_call_unresolved:
  787.       case    as_op:
  788.       case    as_un_op:
  789.                 name = N_AST1(node);
  790.                 arg_list = N_AST2(node);
  791.                 find_old(name);
  792.                 FORTUP(arg =(Node), N_LIST(arg_list), ft1);
  793.                     bind_names(arg);
  794.                 ENDFORTUP(ft1);
  795.                 break;
  796.       case    as_attribute:
  797.                 arg1 = N_AST2(node);
  798.                 arg2 = N_AST3(node);
  799.                 bind_names(arg1);
  800.                 bind_names(arg2);
  801.                 break;
  802.     } /* End switch */
  803. }
  804.  
  805. static Tuple collect_generic_formals(Node generic_part_node)
  806. /*;collect_generic_formals*/
  807. {
  808.     Tuple    gen_list;
  809.     Node    n, id_list_node, init_node, id_node, spec_node;
  810.     int        nk;
  811.     Fortup    ft1, ft2;
  812.     Tuple    tup;
  813.     /*
  814.      * Collect names of generic parameters, and defaults when present.
  815.      * Return a list of pairs [unique_name, default], which is attached to
  816.      * the generic object to simplify instantiation.
  817.      */
  818.  
  819.     if (cdebug2 > 3)
  820.         TO_ERRFILE("AT PROC: collect_generic_formals");
  821.     gen_list = tup_new(0);
  822.  
  823.     FORTUP(n =(Node), N_LIST(generic_part_node), ft1);
  824.         nk = N_KIND(n);
  825.         if (nk == as_generic_obj) {
  826.             id_list_node = N_AST1(n);
  827.             init_node = N_AST4(n);
  828.             FORTUP(id_node=(Node), N_LIST(id_list_node), ft2);
  829.                 tup = tup_new(2);
  830.                 tup[1] = (char *) N_UNQ(id_node);
  831.                 tup[2] = (char *) init_node;
  832.                 gen_list = tup_with(gen_list, (char *) tup);
  833.             ENDFORTUP(ft2);
  834.         }
  835.         else if (nk == as_generic_subp) {
  836.             spec_node = N_AST1(n);
  837.             init_node = N_AST2(n);
  838.             id_node = N_AST1(spec_node);
  839.             tup = tup_new(2);
  840.             tup[1] = (char *) N_UNQ(id_node);
  841.             tup[2] = (char *) init_node;
  842.             gen_list = tup_with(gen_list, (char *) tup);
  843.         }
  844.         else {    /*Generic type definition*/
  845.             id_node = N_AST1(n);
  846.             tup = tup_new(2);
  847.             tup[1] = (char *) N_UNQ(id_node);
  848.             tup[2] = (char *) OPT_NODE;
  849.             gen_list = tup_with(gen_list, (char *) tup);
  850.         }
  851.     ENDFORTUP(ft1);
  852.     return gen_list;
  853. }
  854.  
  855. void subprog_instance(Node node) /*;subprog_instance*/
  856. {
  857.     Node    id_node, gen_node, spec_node, instance_node, body_node,stmt_node;
  858.     char    *new_id, *body_name;
  859.     Symbol    gen_name;
  860.     int        kind;
  861.     Tuple    generics, instance_list;
  862.     Tuple    formals;
  863.     Symbol    return_type;
  864.     Tuple    new_info;
  865.     Symbol    new_return;
  866.     Tuple    new_specs;
  867.     Symbol    proc_name;
  868.     Tuple    tup;
  869.     Fortup    ft1;
  870.     Symbol    new_f, f;
  871.     Tuple    new_formals;
  872.     Symbolmap    type_map;
  873.     int        ii;
  874.     int        has_default = FALSE;
  875.     Tuple    newtup;
  876.  
  877.     /*
  878.      * Create an instantiation of a generic procedure.
  879.      *
  880.      * To construct     the new instance, we  first process the instantiation of
  881.      * the    generics. This yields a series    of renames  statements, which map
  882.      * the generic parameters  into      actual types and  subprograms. This map
  883.      * is used to rename all generic entities within the spec and body of the
  884.      * generic object, to yield the AST and SYMBTAB for the instantiated one.
  885.      */
  886.     if (cdebug2 > 3)
  887.         TO_ERRFILE("AT PROC : subprog_instance");
  888.  
  889.     id_node     = N_AST1(node);
  890.     gen_node = N_AST2(node);
  891.     instance_node = N_AST3(node);
  892.     /* instantiate_generics adds to list - don't want to modify OPT_NODE */
  893.     if (instance_node == OPT_NODE) {
  894.         instance_node = node_new(as_list);
  895.         N_LIST(instance_node) = tup_new(0);
  896.         N_AST3(node) = instance_node;
  897.     }
  898.     new_id = N_VAL(id_node);
  899.     new_compunit("su", id_node);
  900.     find_old(gen_node);
  901.     gen_name = N_UNQ(gen_node);
  902.     if (gen_name == (Symbol)0) gen_name = symbol_any_id;
  903.     /*
  904.      * In the case where the instantiation is a compilation unit, the context
  905.      * of the generic body needs to be transferred to the instatiation. This
  906.      * is done by adding the body of the generic (if it has been seen) to the
  907.      * all_vis insuring that the body is loaded and all that it references
  908.      * is loaded (transitivly) in INIT_GEN.
  909.      */
  910.     if (IS_COMP_UNIT) {
  911.         body_name = strjoin("su", ORIG_NAME(gen_name));
  912.         if (unitNumberFromLibUnit(body_name))
  913.             all_vis = tup_with(all_vis, body_name);
  914.     }
  915.     kind = ( N_KIND(node) == as_procedure_instance ) ? na_procedure
  916.         : na_function;
  917.  
  918.     if ((kind == na_procedure && 
  919.       (NATURE(gen_name) != na_generic_procedure
  920.       && NATURE(gen_name) != na_generic_procedure_spec))
  921.       || (kind == na_function && (NATURE(gen_name) != na_generic_function
  922.       && NATURE(gen_name) != na_generic_function_spec))) {
  923. #ifdef ERRNUM
  924.         l2_errmsgn(51, nature_str(kind), 52, gen_node);
  925. #else
  926.         errmsg_l("not a generic ", nature_str(kind), "12.1, 12.3", gen_node);
  927. #endif
  928.         return;
  929.     }
  930. #ifdef XREF
  931.     TO_XREF(gen_name);
  932. #endif
  933.     tup = SIGNATURE(gen_name);
  934.     generics = (Tuple) tup[1];
  935.     formals = (Tuple) tup[2];
  936.     body_node = (Node) tup[3];
  937.     return_type = TYPE_OF(gen_name);
  938.  
  939.     /* Now match generic specification with instantiation.*/
  940.  
  941.     node_map = nodemap_new();   /* initialize */
  942.     tup = instantiate_generics(generics, instance_node);
  943.     instance_list = (Tuple) tup[1];
  944.     type_map= (Symbolmap) tup[2];
  945.     /*
  946.      * Use the instantiated generic types to obtain the actual signature and
  947.      * return type of the new procedure.
  948.      * Set default expression nodes temporarily to opt_node for the 
  949.      * call to chain_overloads (so that we avoid reprocessing them
  950.      * in process_formals). 
  951.      * Due to this kludge, we also test here (explicitly) that default 
  952.      * parameters are not specified for operator symbols.
  953.      * They are instantiated upon return from chain_overloads.
  954.      */
  955.     new_info = tup_new(tup_size(formals));
  956.     FORTUPI(f=(Symbol), formals, ii, ft1);
  957.         newtup = tup_new(4);
  958.         newtup[1] = (char *)ORIG_NAME(f);
  959.         newtup[2] = (char *)NATURE(f);
  960.         newtup[3] = (char *)replace(TYPE_OF(f), type_map);
  961.         newtup[4] = (char *)OPT_NODE;      /* temporarily */
  962.         new_info[ii] = (char *) newtup;
  963.         if ((Node)default_expr(f) != OPT_NODE)
  964.             has_default = TRUE;
  965.     ENDFORTUP(ft1);
  966.     new_return = replace(return_type, type_map);
  967.  
  968.     new_specs = tup_new(3);
  969.     new_specs[1] = (char *) kind;
  970.     new_specs[2] = (char *) new_return;
  971.     new_specs[3]= (char *) new_info;
  972.  
  973.     if (in_op_designators(new_id )) { /* check format, if operator spec */
  974.         check_new_op(id_node, new_info, new_return);
  975.         if (has_default)
  976. #ifdef ERRNUM
  977.             errmsgn(53, 54, instance_node);
  978. #else
  979.         errmsg("Initializations not allowed for operators", "6.7", instance_node);
  980. #endif
  981.     }
  982.     /* Create new overloadable object with these specs.*/
  983.  
  984.     proc_name = chain_overloads(new_id, kind, new_return, new_info, (Symbol)0,
  985.       OPT_NODE);
  986.     /*
  987.      * in the body of the procedure, replace the generic name with the
  988.      * instantiated name. (it appears on the return statement, and of
  989.      * course in any recursive call).
  990.      * Also, map the names of the formals parameters into the names they
  991.      * have in the instantiated procedure (the actual formals ?)
  992.      * Instantiate default expressions for formals.
  993.      */
  994.     /* map the formals of the generic into the formals of the instantiation.*/
  995.  
  996.     new_formals = SIGNATURE(proc_name);
  997.     FORTUPI(new_f=(Symbol), new_formals, ii, ft1);
  998.         symbolmap_put(type_map, (Symbol) formals[ii], new_f);
  999.         default_expr(new_f) = (Tuple) instantiate_tree(
  1000.           (Node) default_expr((Symbol)formals[ii]), type_map);
  1001.     ENDFORTUP(ft1);
  1002.     /* in the body of the subprogram, the generic name is replaced by the
  1003.      * instantiated name. (it appears  on the  return  statement,  and of
  1004.      * course in any recursive call). 
  1005.      */
  1006.     symbolmap_put(type_map, gen_name, proc_name);
  1007.     N_UNQ(id_node) = proc_name;
  1008.  
  1009.     if (body_node == OPT_NODE) {
  1010.         /* Attach type_map to node for subsequent instantiation (expander).
  1011.          * For visibility purposes, only the formals of the subprogram are
  1012.          * needed; the symbol table instantiation  will  also take place in
  1013.          * the binder.
  1014.          */
  1015.         /* We must call instantiate_sybmtab here in order to have instantiated
  1016.          * items placed in appropriate declared maps
  1017.          */
  1018.         newtup = instantiate_symbtab(gen_name, proc_name, type_map);
  1019.         type_map = (Symbolmap) newtup[1];
  1020.         newtup = tup_new(2);
  1021.         newtup[1] = (char *) type_map;
  1022.         newtup[2] = (char *) TRUE;
  1023.         N_AST4(node) = new_instance_node(newtup);
  1024.         /* original instance node not needed further */
  1025.         if (instance_node != OPT_NODE)
  1026.             N_KIND(N_AST3(node)) = as_list;
  1027.         else N_AST3(node) = node_new(as_list);
  1028.         /* to be included with decls in body */
  1029.         N_LIST(N_AST3(node)) = instance_list;
  1030.     }
  1031.     else {
  1032.         instantiate_subprog_tree(node, type_map);
  1033.         /*
  1034.           * Take the subprogram created by the instantiation and reformat
  1035.           * the subprogram node to be of a form as_subprogram_tr with the
  1036.           * specifcation part detached from the tree. Move up the id_node
  1037.           * (subprogram name) info to the subprogram node. The stmt_node 
  1038.           * needs to be moved to N_AST1 so that N_UNQ field can be used
  1039.           * to store unique name of subprogram.
  1040.           */
  1041.         spec_node = N_AST1(node);
  1042.         stmt_node = N_AST3(node);
  1043.         id_node = N_AST1(spec_node);
  1044.         N_KIND(node) = as_subprogram_tr;
  1045.         N_AST1(node) = stmt_node;
  1046.         N_UNQ(node) = N_UNQ(id_node);
  1047.         /* 
  1048.           * Emit the code that instantiates the generic parameters in front of  
  1049.           * the subprogram.
  1050.           */
  1051.         if (tup_size(instance_list) > 0)
  1052.             make_insert_node(node, instance_list, copy_node(node));
  1053.     }
  1054.  
  1055.     save_subprog_info(proc_name);
  1056. }
  1057.  
  1058. void package_instance(Node node)    /*;package_instance*/
  1059. {
  1060.     Node    id_node, gen_node, instance_node;
  1061.     Symbol    package, gen_name;
  1062.     Tuple    instance_list;
  1063.     Symbolmap    type_map;
  1064.     Node    package_node;
  1065.     Tuple    tup, gen_list;
  1066.     char     *body_name;
  1067.     int        is_comp;
  1068.  
  1069.     if (cdebug2 > 3)
  1070.         TO_ERRFILE("AT PROC : package_instance");
  1071.     /*
  1072.      * Create  an  instantiation of a generic  package. The renaming and
  1073.      * instantiation of local objects is done as for subprograms.
  1074.      */
  1075.     is_comp = IS_COMP_UNIT;
  1076.     id_node = N_AST1(node);
  1077.     gen_node= N_AST2(node);
  1078.     instance_node = N_AST3(node);
  1079.     /* instantiate_generics adds to list - don't want to modify OPT_NODE */
  1080.     if (instance_node == OPT_NODE) {
  1081.         instance_node = node_new(as_list);
  1082.         N_LIST(instance_node) = tup_new(0);
  1083.         N_AST3(node) = instance_node;
  1084.     }
  1085.     new_package(id_node, na_package_spec);
  1086.     package = scope_name;
  1087.  
  1088.     find_old(gen_node);
  1089.     gen_name = N_UNQ(gen_node);
  1090.     if (gen_name == (Symbol)0) gen_name =  symbol_any_id;
  1091.     /* TBSL: the context of the generic needs to be transferred to the
  1092.      * instantiation in the case of a compilation unit. (see mod in
  1093.      * subprogram instance).
  1094.      */
  1095.     if (is_comp) {
  1096.         body_name = strjoin("bo", ORIG_NAME(gen_name));
  1097.         if (unitNumberFromLibUnit(body_name))
  1098.             all_vis = tup_with(all_vis, body_name);
  1099.     }
  1100.  
  1101.     /*
  1102.      * new_compunit will have already been called under the asssumption
  1103.      * that the current compilation unit is a non-generic package.    This
  1104.      * may be inefficient, but the second calls to new_compunit and
  1105.      * establish_context will act correctly.
  1106.      * Build temporary node "package_node" to call new_compunit.
  1107.      */
  1108.     package_node = node_new(as_simple_name);
  1109.     copy_span(id_node, package_node);
  1110.     N_VAL(package_node) = N_VAL(id_node);
  1111.     /* TBSL - SETL has 'spec instance' - I am doing as 'spec'  ds 30 jul */
  1112.     new_compunit("sp", package_node);
  1113.     if (
  1114.         /* !is_identifier(gen_name) ||  */
  1115.         /* is_identifier will always be true because was set above */
  1116.       (NATURE(gen_name) !=na_generic_package
  1117.       && NATURE(gen_name) !=na_generic_package_spec) ) {
  1118. #ifdef ERRNUM
  1119.         errmsgn(55, 56, gen_node);
  1120. #else
  1121.         errmsg("not a generic package", "12.1", gen_node);
  1122. #endif
  1123.         popscope();
  1124.         return;
  1125.     }
  1126.     else if (in_open_scopes(gen_name)) {
  1127. #ifdef ERRNUM
  1128.         errmsgn(57, 58, gen_node);
  1129. #else
  1130.         errmsg("Recursive instantiation not allowed", "12.3", gen_node);
  1131. #endif
  1132.         popscope();
  1133.         return;
  1134.     }
  1135. #ifdef XREF
  1136.     TO_XREF(gen_name);
  1137. #endif
  1138.     tup = SIGNATURE(gen_name);
  1139.     gen_list = (Tuple) tup[1];
  1140.     node_map = nodemap_new();   /* initialize */
  1141.     tup = instantiate_generics(gen_list, instance_node);
  1142.     instance_list = (Tuple) tup[1];
  1143.     type_map = (Symbolmap) tup[2];
  1144.     symbolmap_put(type_map, gen_name, package);
  1145.     instantiate_pack_tree(node, type_map, instance_list);
  1146.     end_specs(package);
  1147.     /*
  1148.      * The instantiated object is a package, although it appears syntact-
  1149.      * ically as a package spec. 
  1150.      */
  1151.     NATURE(package) = na_package;
  1152. }
  1153.